home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / Examples / window-example.lisp < prev   
Encoding:
Text File  |  1993-02-26  |  3.6 KB  |  103 lines  |  [TEXT/CCL2]
  1. ; Example window.
  2. ;
  3. ; This is a simple example of how to create a typical window
  4. ; using MCL. 
  5. ;
  6. ;
  7. ; To use, load this file then eval this expression:
  8. ; (make-instance 'my-window)
  9.  
  10. ;-------------------------------
  11. (in-package ccl)                        ; specify package
  12.  
  13. (require :quickdraw)                    ; needed for paint-rect
  14.  
  15. ;-------------------------------
  16.  
  17. (defclass my-window (window)
  18.   ((color :initform 'red :accessor color :initarg :color))
  19.   (:default-initargs
  20.     :color-p t                          ; use color
  21.     :window-title "I'm a MY-WINDOW"     ; title
  22.     :window-show nil))                  ; hide window until initialize-instance runs
  23.  
  24.  
  25. (defmethod initialize-instance :after ((self my-window) &rest ignore)
  26.   (declare (ignore ignore))
  27.   (let ((radio-button1 (make-instance 'radio-button-dialog-item
  28.                          :dialog-item-text "Red"
  29.                          :view-nick-name 'red
  30.                          :view-position #@(10 10)
  31.                          :radio-button-pushed-p t
  32.                          :dialog-item-action #'push-color-button))
  33.         (radio-button2 (make-instance 'radio-button-dialog-item
  34.                          :dialog-item-text "Green"
  35.                          :view-nick-name 'green
  36.                          :view-position #@(10 30)
  37.                          :dialog-item-action #'push-color-button))
  38.         (radio-button3 (make-instance 'radio-button-dialog-item
  39.                          :dialog-item-text "Blue"
  40.                          :view-nick-name 'blue
  41.                          :view-position #@(10 50)
  42.                          :dialog-item-action #'push-color-button))
  43.         (push-button (make-instance 'button-dialog-item
  44.                        :view-nick-name 'boink-button
  45.                        :dialog-item-text "Boink!"
  46.                        :dialog-item-action
  47.                        #'(lambda (button) 
  48.                            (format t "~%You have pressed ~A and the color is ~A"
  49.                                    button (color (view-container button)))))))
  50.     (add-subviews self 
  51.                   radio-button1 radio-button2 
  52.                   radio-button3 push-button)
  53.     (resize-subviews self)              ; move button
  54.     (window-show self)))                ; then show finished window
  55.  
  56. ;---------
  57. ; What happens when you push a button
  58.  
  59. (defun push-color-button (button)
  60.   (let ((choice (view-nick-name button))
  61.         (parent (view-container button)))
  62.     (setf (color parent) choice)
  63.     (invalidate-view parent)))
  64.  
  65. ;---------
  66. ; Appearance
  67.  
  68. ; Draw a big color rectangle
  69. (defmethod view-draw-contents ((self my-window))
  70.   (call-next-method)                    ; call other view-draw-contents methods too!
  71.   (with-fore-color (ecase (color self)
  72.                      (red *red-color*)
  73.                      (green *green-color*)
  74.                      (blue *blue-color*))
  75.     (paint-rect self #@(100 10) #@(200 70))))
  76.  
  77. ;---------
  78. ; Geometry
  79. ;
  80.  
  81. ; Returns a position for the button in the corner.
  82. (defmethod corner-position (button)
  83.   (let ((margin #@(20 20)))
  84.     (subtract-points (view-size (view-container button))
  85.                      (add-points margin (view-size button)))))
  86.  
  87. ; Automatically move the "boink" button when the window is resized.
  88. (defmethod resize-subviews ((self my-window))
  89.   (let ((button (view-named 'boink-button self)))
  90.     (set-view-position button (corner-position button))))
  91.  
  92.  
  93. ; Update when window is resized.
  94. (defmethod set-view-size :after ((self my-window) h &optional v)
  95.   (declare (ignore h v))
  96.   (resize-subviews self))
  97.  
  98. ; Update when the window's zoombox is clicked.
  99. (defmethod window-zoom-event-handler :after ((self my-window) message)
  100.   (declare (ignore message))
  101.   (resize-subviews self))
  102.  
  103.